home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / defs.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-09-09  |  27.7 KB  |  823 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. (eval-when (compile load eval)
  31.   
  32. (defvar *defclass-times*   '(load eval))    ;Probably have to change this
  33.                         ;if you use defconstructor.
  34. (defvar *defmethod-times*  '(load eval))
  35. (defvar *defgeneric-times* '(load eval))
  36.  
  37. (defvar *boot-state* ())            ;NIL
  38.                         ;EARLY
  39.                         ;BRAID
  40.                         ;COMPLETE
  41.  
  42. )
  43.  
  44. (eval-when (load eval)
  45.   (when (eq *boot-state* 'complete)
  46.     (error "Trying to load (or compile) PCL in an environment in which it~%~
  47.             has already been loaded.  This doesn't work, you will have to~%~
  48.             get a fresh lisp (reboot) and then load PCL."))
  49.   (when *boot-state*
  50.     (cerror "Try loading (or compiling) PCL anyways."
  51.         "Trying to load (or compile) PCL in an environment in which it~%~
  52.              has already been partially loaded.  This may not work, you may~%~
  53.              need to get a fresh lisp (reboot) and then load PCL."))
  54.   )
  55.  
  56.  
  57.  
  58. ;;;
  59. ;;; This is like fdefinition on the Lispm.  If Common Lisp had something like
  60. ;;; function specs I wouldn't need this.  On the other hand, I don't like the
  61. ;;; way this really works so maybe function specs aren't really right either?
  62. ;;; 
  63. ;;; I also don't understand the real implications of a Lisp-1 on this sort of
  64. ;;; thing.  Certainly some of the lossage in all of this is because these
  65. ;;; SPECs name global definitions.
  66. ;;;
  67. ;;; Note that this implementation is set up so that an implementation which
  68. ;;; has a 'real' function spec mechanism can use that instead and in that way
  69. ;;; get rid of setf generic function names.
  70. ;;;
  71. (defmacro parse-gspec (spec
  72.                (non-setf-var . non-setf-case)
  73.                (setf-var . setf-case))
  74.   (declare (indentation 1 1))
  75.   (once-only (spec)
  76.     `(cond (#-setf (symbolp ,spec) #+setf t
  77.         (let ((,non-setf-var ,spec)) ,@non-setf-case))
  78.        ((and (listp ,spec)
  79.          (eq (car ,spec) 'setf)
  80.          (symbolp (cadr ,spec)))
  81.         (let ((,setf-var (cadr ,spec))) ,@setf-case))
  82.        (t
  83.         (error
  84.           "Can't understand ~S as a generic function specifier.~%~
  85.                It must be either a symbol which can name a function or~%~
  86.                a list like ~S, where the car is the symbol ~S and the cadr~%~
  87.                is a symbol which can name a generic function."
  88.           ,spec '(setf <foo>) 'setf)))))
  89.  
  90. ;;;
  91. ;;; If symbol names a function which is traced or advised, return the
  92. ;;; unadvised, traced etc. definition.  This lets me get at the generic
  93. ;;; function object even when it is traced.
  94. ;;;
  95. (defun unencapsulated-fdefinition (symbol)
  96.   #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
  97.   #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
  98.   #+excl  (or (excl::encapsulated-basic-definition symbol)
  99.           (symbol-function symbol))
  100.   #+xerox (il:virginfn symbol)
  101.   #+CLISP (or (get symbol 'sys::traced-definition) (symbol-function symbol))
  102.   #+setf (fdefinition symbol)
  103.   #-(or Lispm Lucid excl Xerox CLISP setf) (symbol-function symbol))
  104.  
  105. ;;;
  106. ;;; If symbol names a function which is traced or advised, redefine
  107. ;;; the `real' definition without affecting the advise.
  108. ;;;
  109. (defun fdefine-carefully (symbol new-definition)
  110.   #+Lispm (si:fdefine symbol new-definition t t)
  111.   #+Lucid (let ((lucid::*redefinition-action* nil))
  112.         (setf (symbol-function symbol) new-definition))
  113.   #+excl  (setf (symbol-function symbol) new-definition)
  114.   #+xerox (let ((advisedp (member symbol il:advisedfns :test #'eq))
  115.                 (brokenp (member symbol il:brokenfns :test #'eq)))
  116.         ;; In XeroxLisp (late of envos) tracing is implemented
  117.         ;; as a special case of "breaking".  Advising, however,
  118.         ;; is treated specially.
  119.             (xcl:unadvise-function symbol :no-error t)
  120.             (xcl:unbreak-function symbol :no-error t)
  121.             (setf (symbol-function symbol) new-definition)
  122.             (when brokenp (xcl:rebreak-function symbol))
  123.             (when advisedp (xcl:readvise-function symbol)))
  124.   #+CLISP (let ((traced (get symbol 'sys::traced-definition)))
  125.             (if traced
  126.               (if (consp traced)
  127.                 (progn
  128.                   (sys::untrace2 symbol)
  129.                   (setf (symbol-function symbol) new-definition))
  130.                 (setf (get symbol 'sys::traced-definition) new-definition))
  131.               (setf (symbol-function symbol) new-definition)))
  132.   #+setf (setf (fdefinition symbol) new-definition)
  133.   #-(or Lispm Lucid excl Xerox CLISP setf)
  134.   (setf (symbol-function symbol) new-definition)
  135.   
  136.   new-definition)
  137.  
  138. (defun gboundp (spec)
  139.   (parse-gspec spec
  140.     (name (fboundp name))
  141.     (name (fboundp (get-setf-function-name name)))))
  142.  
  143. (defun gmakunbound (spec)
  144.   (parse-gspec spec
  145.     (name (fmakunbound name))
  146.     (name (fmakunbound (get-setf-function-name name)))))
  147.  
  148. (defun gdefinition (spec)
  149.   (parse-gspec spec
  150.     (name (or #-setf (macro-function name)        ;??
  151.           (unencapsulated-fdefinition name)))
  152.     (name (unencapsulated-fdefinition (get-setf-function-name name)))))
  153.  
  154. (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec)
  155.   (parse-gspec spec
  156.     (name (fdefine-carefully name new-value))
  157.     (name (fdefine-carefully (get-setf-function-name name) new-value))))
  158.  
  159.  
  160. (proclaim '(special *the-class-t* 
  161.                     *the-class-vector* *the-class-symbol*
  162.                     *the-class-string* *the-class-sequence*
  163.                     *the-class-rational* *the-class-ratio*
  164.                     *the-class-number* *the-class-null* *the-class-list*
  165.                     *the-class-integer* *the-class-float* *the-class-cons*
  166.                     *the-class-complex* *the-class-character*
  167.                     *the-class-bit-vector* *the-class-array*
  168.  
  169.                     *the-class-slot-object*
  170.                     *the-class-standard-object*
  171.                     *the-class-structure-object*
  172.                     *the-class-class*
  173.                     *the-class-method*
  174.                     *the-class-generic-function*
  175.                     *the-class-built-in-class*
  176.                     *the-class-slot-class*
  177.                     *the-class-structure-class*
  178.                     *the-class-standard-class*
  179.                     *the-class-funcallable-standard-class*
  180.                     *the-class-standard-method*
  181.                     *the-class-standard-generic-function*
  182.                     *the-class-standard-direct-slot-definition*
  183.                     *the-class-standard-effective-slot-definition*))
  184.  
  185. (proclaim '(special *the-wrapper-of-t*
  186.                     *the-wrapper-of-vector* *the-wrapper-of-symbol*
  187.                     *the-wrapper-of-string* *the-wrapper-of-sequence*
  188.                     *the-wrapper-of-rational* *the-wrapper-of-ratio*
  189.                     *the-wrapper-of-number* *the-wrapper-of-null*
  190.                     *the-wrapper-of-list* *the-wrapper-of-integer*
  191.                     *the-wrapper-of-float* *the-wrapper-of-cons*
  192.                     *the-wrapper-of-complex* *the-wrapper-of-character*
  193.                     *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
  194.  
  195. (defun coerce-to-class (class &optional make-forward-referenced-class-p)
  196.   (declare (type boolean make-forward-referenced-class-p))
  197.   (if (symbolp class)
  198.       (or (find-class class (not make-forward-referenced-class-p))
  199.       (ensure-class class))
  200.       class))
  201.  
  202. (defun specializer-from-type (type &aux args)
  203.   (when (consp type)
  204.     (setq args (cdr type) type (car type)))
  205.   (cond ((symbolp type)
  206.      (or (and (null args) (find-class type))
  207.          (ecase type
  208.            (class    (coerce-to-class (car args)))
  209.            (class-eq (class-eq-specializer (coerce-to-class (car args))))
  210.            (eql      (intern-eql-specializer (car args))))))
  211.     ((specializerp type) type)))
  212.  
  213. (defun type-from-specializer (specl)
  214.   (when (symbolp specl)
  215.     (setq specl (find-class specl))) ;(or (find-class specl nil) (ensure-class specl))
  216.   (cond ((consp specl)
  217.          (unless (memq (car specl) '(class class-eq eql))
  218.            (error "~S is not a legal specializer type" specl))
  219.          specl)
  220.         ((specializerp specl)
  221.          (specializer-type specl))
  222.         (t
  223.          (error "~s is neither a type nor a specializer" specl))))
  224.  
  225. (defun type-class (type)
  226.   (declare (special *the-class-t*))
  227.   (setq type (type-from-specializer type))
  228.   (if (atom type)
  229.       *the-class-t*
  230.       (case (car type)
  231.         (eql (class-of (cadr type)))
  232.         (class-eq (cadr type))
  233.         (class (cadr type)))))
  234.  
  235. (defun class-eq-type (class)
  236.   (specializer-type (class-eq-specializer class)))
  237.  
  238. (defun inform-type-system-about-std-class (name)
  239.   (let ((predicate-name (make-type-predicate-name name)))
  240.     (setf (symbol-function predicate-name) (make-type-predicate name))
  241.     (do-satisfies-deftype name predicate-name)))
  242.  
  243. (defun make-type-predicate (name)
  244.   (let ((cell (find-class-cell name)))
  245.     #'(lambda (x)
  246.     (funcall (the compiled-function (find-class-cell-predicate cell)) x))))
  247.  
  248.  
  249. ;This stuff isn't right.  Good thing it isn't used.
  250. ;The satisfies predicate has to be a symbol.  There is no way to
  251. ;construct such a symbol from a class object if class names change.
  252. (defun class-predicate (class)
  253.   (when (symbolp class) (setq class (find-class class)))
  254.   #'(lambda (object)
  255.       (memq class (wrapper-class-precedence-list (wrapper-of object)))))
  256.  
  257. (defun make-class-eq-predicate (class)
  258.   (when (symbolp class) (setq class (find-class class)))
  259.   #'(lambda (object) (eq class (class-of object))))
  260.  
  261. (defun make-eql-predicate (eql-object)
  262.   #'(lambda (object) (eql eql-object object)))
  263.  
  264. #|| ; The argument to satisfies must be a symbol.  
  265. (deftype class (&optional class)
  266.   (if class
  267.       `(satisfies ,(class-predicate class))
  268.       `(satisfies ,(class-predicate 'class))))
  269.  
  270. (deftype class-eq (class)
  271.   `(satisfies ,(make-class-eq-predicate class)))
  272. ||#
  273.  
  274. (deftype eql (type-object)
  275.   `(member ,type-object))
  276.  
  277. ;;;
  278. ;;; These functions are a pale imitiation of their namesake.  They accept
  279. ;;; class objects or types where they should.
  280. ;;; 
  281. (defun *normalize-type (type)
  282.   (cond ((consp type)
  283.          (if (member (car type) '(not and or))
  284.              `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
  285.              (if (null (cdr type))
  286.                  (*normalize-type (car type))
  287.                  type)))
  288.         ((symbolp type)
  289.          (let ((class (find-class type nil)))
  290.            (if class
  291.                (let ((type (specializer-type class)))
  292.          (if (listp type) type `(,type)))
  293.                `(,type))))
  294.         ((specializerp type)
  295.          (specializer-type type))
  296.         (t
  297.          (error "~s is not a type" type))))
  298.  
  299. (defun unparse-type-list (tlist)
  300.   (mapcar #'unparse-type tlist))
  301.  
  302. (defun unparse-type (type)
  303.   (if (atom type)
  304.       (if (specializerp type)
  305.           (unparse-type (specializer-type type))
  306.           type)
  307.       (case (car type)
  308.         (eql type)
  309.         (class-eq `(class-eq ,(class-name (cadr type))))
  310.         (class (class-name (cadr type)))
  311.         (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
  312.  
  313. (defun convert-to-system-type (type)
  314.   (case (car type)
  315.     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type))))
  316.     (class (class-name (cadr type))) ; it had better be a named class
  317.     (class-eq (class-name (cadr type))) ; this one is impossible to do right
  318.     (eql type)
  319.     (t (if (null (cdr type))
  320.        (car type)
  321.        type))))
  322.  
  323. (declaim (ftype (function (T T) boolean) *typep))
  324. (defun *typep (object type)
  325.   (setq type (*normalize-type type))
  326.   (cond ((memq (car type) '(eql wrapper-eq class-eq class))
  327.          (specializer-applicable-using-type-p type `(eql ,object)))
  328.         ((eq (car type) 'not)
  329.          (not (*typep object (cadr type))))
  330.         (t
  331.          (typep object (convert-to-system-type type)))))
  332.  
  333. #-kcl
  334. (declaim (ftype (function (T T) (values boolean boolean)) *subtypep))
  335. (defun *subtypep (type1 type2)
  336.   (setq type1 (*normalize-type type1))
  337.   (setq type2 (*normalize-type type2))
  338.   (if (member (car type2) '(eql wrapper-eq class-eq class))
  339.       (multiple-value-bind (app-p maybe-app-p)
  340.           (specializer-applicable-using-type-p type2 type1)
  341.         (declare (type boolean app-p maybe-app-p))
  342.         (values app-p (or app-p (not maybe-app-p))))
  343.       (subtypep (convert-to-system-type type1)
  344.         (convert-to-system-type type2))))
  345.  
  346. (defun do-satisfies-deftype (name predicate)
  347.   #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral CLISP)
  348.   (let* ((specifier `(satisfies ,predicate))
  349.      (expand-fn #'(lambda (&rest ignore)
  350.             (declare (ignore ignore))
  351.             specifier)))
  352.     ;; Specific ports can insert their own way of doing this.  Many
  353.     ;; ports may find the expand-fn defined above useful.
  354.     ;;
  355.     (or #+:Genera
  356.     (setf (get name 'deftype) expand-fn)
  357.     #+(and :Lucid (not :Prime))
  358.     (system::define-macro `(deftype ,name) expand-fn nil)
  359.     #+ExCL
  360.     (setf (get name 'excl::deftype-expander) expand-fn)
  361.     #+:coral
  362.     (setf (get name 'ccl::deftype-expander) expand-fn)
  363.         #+CLISP
  364.         (setf (get name 'sys::deftype-expander) expand-fn)))
  365.   #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral CLISP)
  366.   ;; This is the default for ports for which we don't know any
  367.   ;; better.  Note that for most ports, providing this definition
  368.   ;; should just speed up class definition.  It shouldn't have an
  369.   ;; effect on performance of most user code.
  370.   (eval `(deftype ,name () '(satisfies ,predicate))))
  371.  
  372. (defun make-type-predicate-name (name &optional kind)
  373.   (when (null name) (error "This shouldn't happen."))
  374.   (if (symbol-package name)
  375.       (intern (format nil
  376.               "~@[~A ~]TYPE-PREDICATE ~A ~A"
  377.               kind
  378.               (package-name (symbol-package name))
  379.               (symbol-name name))
  380.           *the-pcl-package*)
  381.       (make-symbol (format nil
  382.                "~@[~A ~]TYPE-PREDICATE ~A"
  383.                kind
  384.                (symbol-name name)))))
  385.  
  386.  
  387.  
  388.  
  389. (defvar *built-in-class-symbols* ())
  390. (defvar *built-in-wrapper-symbols* ())
  391.  
  392. (defun get-built-in-class-symbol (class-name)
  393.   (or (cadr (assq class-name *built-in-class-symbols*))
  394.       (let ((symbol (intern (format nil
  395.                     "*THE-CLASS-~A*"
  396.                     (symbol-name class-name))
  397.                 *the-pcl-package*)))
  398.     (push (list class-name symbol) *built-in-class-symbols*)
  399.     symbol)))
  400.  
  401. (defun get-built-in-wrapper-symbol (class-name)
  402.   (or (cadr (assq class-name *built-in-wrapper-symbols*))
  403.       (let ((symbol (intern (format nil
  404.                     "*THE-WRAPPER-OF-~A*"
  405.                     (symbol-name class-name))
  406.                 *the-pcl-package*)))
  407.     (push (list class-name symbol) *built-in-wrapper-symbols*)
  408.     symbol)))
  409.  
  410.  
  411.  
  412.  
  413. (pushnew 'class *variable-declarations*)
  414. (pushnew 'variable-rebinding *variable-declarations*)
  415.  
  416. (defun variable-class (var env)
  417.   (caddr (variable-declaration 'class var env)))
  418.  
  419.  
  420.  
  421.  
  422. ;;;
  423. ;;; This is used by combined methods to communicate the next methods to
  424. ;;; the methods they call.  This variable is captured by a lexical variable
  425. ;;; of the methods to give it the proper lexical scope.
  426. ;;; 
  427. (defvar *next-methods* nil)
  428.  
  429. (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
  430.  
  431. (defvar *umi-gfs*)
  432. (defvar *umi-complete-classes*)
  433. (defvar *umi-reorder*)
  434.  
  435. (defvar *invalidate-discriminating-function-force-p* ())
  436. (defvar *invalid-dfuns-on-stack* ())
  437.  
  438.  
  439. (defvar *standard-method-combination*)
  440.  
  441. (defvar *slotd-unsupplied* (list '*slotd-unsupplied*))    ;***
  442.  
  443.  
  444. (defmacro define-gf-predicate (predicate-name &rest classes)
  445.   `(progn 
  446.      (defmethod ,predicate-name ((x t)) nil)
  447.      ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
  448.            classes)))
  449.  
  450. (defun make-class-predicate-name (name)
  451.   (intern (format nil "~A::~A class predicate"
  452.                   (package-name (symbol-package name))
  453.                   name)
  454.           *the-pcl-package*))
  455.  
  456. (defun plist-value (object name &optional default)
  457.   (getf (object-plist object) name default))
  458.  
  459. (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
  460.   (setf (getf (object-plist object) name) new-value))
  461.  
  462.  
  463.  
  464. (defvar *built-in-classes*
  465.   ;;
  466.   ;; name       supers     subs                     cdr of cpl
  467.   ;; prototype    predicate-name
  468.   '(;(t         ()         (number sequence array character symbol) ())
  469.     (number     (t)        (complex float rational) (t)
  470.      1        numberp)
  471.     (complex    (number)   ()                       (number t)
  472.      #c(1 1)    complexp)
  473.     (float      (number)   ()                       (number t)
  474.      1.0    floatp)
  475.     (rational   (number)   (integer ratio)          (number t)
  476.      1        rationalp)
  477.     (integer    (rational) ()                       (rational number t)
  478.      1        integerp)
  479.     (ratio      (rational) ()                       (rational number t)
  480.      1/2)
  481.  
  482.     (sequence   (t)        (list vector)            (t)
  483.      nil    sequencep)
  484.     (list       (sequence) (cons null)              (sequence t)
  485.      ()        listp)
  486.     (cons       (list)     ()                       (list sequence t)
  487.      (nil)    consp)
  488.     
  489.  
  490.     (array      (t)        (vector)                 (t)
  491.      #2A((NIL))    arrayp)
  492.     (vector     (array
  493.          sequence) (string bit-vector)      (array sequence t)
  494.      #()    vectorp)
  495.     (string     (vector)   ()                       (vector array sequence t)
  496.      ""        stringp)
  497.     (bit-vector (vector)   ()                       (vector array sequence t)
  498.      #*1    bit-vector-p)
  499.     (character  (t)        ()                       (t)
  500.      #\c    characterp)
  501.    
  502.     (symbol     (t)        (null)                   (t)
  503.      symbol    symbolp)
  504.     (null       (symbol
  505.                  list)     ()                       (symbol list sequence t)
  506.      nil    null)))
  507.  
  508.  
  509. ;;;
  510. ;;; The classes that define the kernel of the metabraid.
  511. ;;;
  512. (defclass t () ()
  513.   (:metaclass built-in-class))
  514.  
  515. (defclass slot-object (t) ()
  516.   (:metaclass slot-class))
  517.  
  518. (defclass structure-object (slot-object) ()
  519.   (:metaclass structure-class))
  520.  
  521. (defstruct (structure-object
  522.          (:constructor |STRUCTURE-OBJECT class constructor|)))
  523.  
  524. (defclass standard-object (slot-object) ())
  525.  
  526. (defclass metaobject (standard-object) ())
  527.  
  528. (defclass specializer (metaobject) 
  529.      ((type
  530.         :initform nil
  531.         :reader specializer-type)))
  532.  
  533. (defclass definition-source-mixin (standard-object)
  534.      ((source
  535.     :initform (load-truename)
  536.     :reader definition-source
  537.     :initarg :definition-source)))
  538.  
  539. (defclass plist-mixin (standard-object)
  540.      ((plist
  541.     :initform ()
  542.     :accessor object-plist)))
  543.  
  544. (defclass documentation-mixin ()
  545.   ((documentation
  546.       :initform NIL
  547.       :initarg :documentation)))
  548.  
  549. (defclass dependent-update-mixin (plist-mixin)
  550.     ())
  551.  
  552. ;;;
  553. ;;; The class CLASS is a specified basic class.  It is the common superclass
  554. ;;; of any kind of class.  It holds all of the documented reader functions from
  555. ;;; the AMOP.  Any class that can be a metaclass must have the class CLASS
  556. ;;; in its class precedence list.
  557. ;;; 
  558. (defclass class (documentation-mixin dependent-update-mixin
  559.                  definition-source-mixin specializer)
  560.      ((default-initargs
  561.         :reader class-default-initargs)
  562.       (direct-default-initargs
  563.         :initform nil
  564.         :reader class-direct-default-initargs)
  565.       (direct-slots
  566.         :initform nil
  567.     :reader class-direct-slots)
  568.       (direct-subclasses
  569.         :initform nil
  570.     :reader class-direct-subclasses)
  571.       (direct-superclasses
  572.         :initform nil
  573.     :reader class-direct-superclasses)
  574.       (finalized-p
  575.         :initform nil
  576.         :reader class-finalized-p)
  577.       (name
  578.     :initform nil
  579.     :initarg  :name
  580.     :reader class-name)
  581.       (class-precedence-list
  582.     :reader class-precedence-list)
  583.       (prototype
  584.         :reader class-prototype)
  585.       (slots
  586.     :reader class-slots)))
  587.  
  588.  
  589. ;;;
  590. ;;; The class PCL-CLASS is an implementation-specific common superclass of
  591. ;;; all specified subclasses of the class CLASS.
  592. ;;; 
  593. (defclass pcl-class (class)
  594.      ((cached-in-generic-functions
  595.         :initform ()
  596.         :reader class-cached-in-generic-functions)
  597.       (can-precede-list
  598.         :initform ()
  599.     :reader class-can-precede-list)
  600.       (class-eq-specializer
  601.         :initform nil
  602.         :reader class-eq-specializer)
  603.       (direct-methods
  604.     :initform (cons nil nil))
  605.       (incompatible-superclass-list
  606.         :initform ()
  607.     :accessor class-incompatible-superclass-list)
  608.       (internal-slotds
  609.         :reader class-internal-slotds
  610.         :documentation
  611.           "List of internal-slotd structure copies of class-slots (for optimization).")
  612.       (wrapper
  613.     :initform nil
  614.     :reader class-wrapper)
  615.       (predicate-name
  616.         :initform nil
  617.     :reader class-predicate-name))
  618.       )
  619.  
  620. (defclass slot-class (pcl-class)
  621.      ((side-effect-internal-slotds
  622.         :reader class-side-effect-internal-slotds
  623.         :documentation
  624.           "List of internal-slotd structure copies of class-slots whose initfunctions
  625.            may have side-effects (for optimization).")))
  626.  
  627. ;;;
  628. ;;; The class STD-CLASS is an implementation-specific common superclass of
  629. ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
  630. ;;; 
  631. (defclass std-class (slot-class)
  632.  ())
  633.  
  634. (defclass standard-class (std-class)
  635.      ())
  636.  
  637. (defclass funcallable-standard-class (std-class)
  638.      ())
  639.     
  640. (defclass forward-referenced-class (pcl-class) ())
  641.  
  642. (defclass built-in-class (pcl-class) ())
  643.  
  644. (defclass structure-class (slot-class)
  645.      ((defstruct-conc-name
  646.         :initform nil
  647.         :reader class-defstruct-conc-name)
  648.       (defstruct-constructor
  649.         :initform nil
  650.     :reader class-defstruct-constructor)
  651.       (from-defclass-p
  652.         :initform nil
  653.     :initarg :from-defclass-p
  654.         :reader class-from-defclass-p)))
  655.  
  656.  
  657. (defclass specializer-with-object (specializer) ())
  658.  
  659. (defclass exact-class-specializer (specializer) ())
  660.  
  661. (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
  662.   ((object :initarg :class :reader specializer-class :reader specializer-object)))
  663.  
  664. (defclass eql-specializer (exact-class-specializer specializer-with-object)
  665.   ((object :initarg :object :reader specializer-object 
  666.        :reader eql-specializer-object)))
  667.  
  668. (defvar *eql-specializer-table* (make-hash-table :test 'eql))
  669.  
  670. (defun intern-eql-specializer (object)
  671.   (or (gethash object *eql-specializer-table*)
  672.       (setf (gethash object *eql-specializer-table*)
  673.         (make-instance 'eql-specializer :object object))))
  674.  
  675.  
  676. ;;;
  677. ;;; Slot definitions.
  678. ;;;
  679. ;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".
  680. ;;;
  681. (defclass slot-definition (documentation-mixin metaobject) 
  682.      ((name
  683.     :initform nil
  684.     :initarg :name
  685.         :accessor slot-definition-name)
  686.       (initform
  687.     :initform nil
  688.     :initarg :initform
  689.     :accessor slot-definition-initform)
  690.       (initfunction
  691.     :initform nil
  692.         :type     (or function null)
  693.     :initarg :initfunction
  694.     :accessor slot-definition-initfunction)
  695.       (readers
  696.     :initform nil
  697.     :initarg :readers
  698.     :accessor slot-definition-readers)
  699.       (writers
  700.     :initform nil
  701.     :initarg :writers
  702.     :accessor slot-definition-writers)
  703.       (initargs
  704.     :initform nil
  705.     :initarg :initargs
  706.     :accessor slot-definition-initargs)
  707.       (type
  708.     :initform t
  709.     :initarg :type
  710.     :accessor slot-definition-type)
  711.       (class
  712.         :initform nil
  713.     :initarg :class
  714.     :accessor slot-definition-class)
  715.       (initfunction-side-effect-free-p
  716.     :initform nil
  717.     :initarg :initfunction-side-effect-free-p
  718.     :accessor slot-definition-initfunction-side-effect-free-p)))
  719.  
  720.  
  721. (defclass standard-slot-definition (slot-definition)
  722.   ((allocation
  723.     :initform :instance
  724.     :initarg :allocation
  725.     :accessor slot-definition-allocation)))
  726.  
  727. (defclass structure-slot-definition (slot-definition)
  728.   ((defstruct-accessor-symbol 
  729.      :initform nil
  730.      :initarg :defstruct-accessor-symbol
  731.      :accessor slot-definition-defstruct-accessor-symbol)
  732.    (internal-reader-function 
  733.      :initform nil
  734.      :initarg :internal-reader-function
  735.      :accessor slot-definition-internal-reader-function)
  736.    (internal-writer-function 
  737.      :initform nil
  738.      :initarg :internal-writer-function
  739.      :accessor slot-definition-internal-writer-function)))
  740.  
  741. (defclass direct-slot-definition (slot-definition)
  742.   ())
  743.  
  744. (defclass effective-slot-definition (slot-definition)
  745.   ((location ; nil, a fixnum, a cons: (slot-name . value)
  746.     :initform nil
  747.     :accessor slot-definition-location)
  748.    (reader-function ; #'(lambda (object) ...)
  749.     :accessor slot-definition-reader-function)
  750.    (writer-function ; #'(lambda (new-value object) ...)
  751.     :accessor slot-definition-writer-function)
  752.    (boundp-function ; #'(lambda (object) ...)
  753.     :accessor slot-definition-boundp-function)
  754.    (accessor-flags
  755.     :initform 0)
  756.    (internal-slotd
  757.     :initform NIL
  758.     :accessor slot-definition-internal-slotd
  759.     :documentation
  760.       "Internal-slotd structure with copies of slot-definition info
  761.        used for optimizations purposes.")))
  762.  
  763. (defclass standard-direct-slot-definition (standard-slot-definition
  764.                        direct-slot-definition)
  765.   ())
  766.  
  767. (defclass standard-effective-slot-definition (standard-slot-definition
  768.                           effective-slot-definition)
  769.   ())
  770.  
  771. (defclass structure-direct-slot-definition (structure-slot-definition
  772.                         direct-slot-definition)
  773.   ())
  774.  
  775. (defclass structure-effective-slot-definition (structure-slot-definition
  776.                            effective-slot-definition)
  777.   ())
  778.  
  779.  
  780.  
  781. (defun slot-reader-undefined (object)
  782.   (error "slot reader-function undefined for ~S" object))
  783.  
  784. (defun slot-writer-undefined (new-value object)
  785.   (declare (ignore new-value))
  786.   (error "slot writer-function undefined for ~S" object))
  787.  
  788. (defun slot-boundp-undefined (object)
  789.   (error "slot boundp-function undefined for ~S" object))
  790.  
  791. (defstruct (internal-slotd
  792.              (:print-function print-internal-slotd))
  793.  (name            NIL  :type symbol)
  794.  (slot-definition NIL)
  795.  (location        NIL)
  796.  (initargs        ()   :type list)
  797.  (initfunction    ()   :type (or function null))
  798.  (reader-function #'slot-reader-undefined :type compiled-function)
  799.  (writer-function #'slot-writer-undefined :type compiled-function)
  800.  (boundp-function #'slot-boundp-undefined :type compiled-function))
  801.  
  802. #+akcl
  803. (si::freeze-defstruct 'internal-slotd)
  804.  
  805. (defun print-internal-slotd (internal-slotd stream depth)
  806.   (declare (ignore depth))
  807.   (printing-random-thing (internal-slotd stream)
  808.     (format stream "internal-slotd ~S"
  809.             (internal-slotd-slot-definition internal-slotd))))
  810.  
  811.  
  812. (defparameter *early-class-predicates*
  813.   '((specializer specializerp)
  814.     (exact-class-specializer exact-class-specializer-p)
  815.     (class-eq-specializer class-eq-specializer-p)
  816.     (eql-specializer eql-specializer-p)
  817.     (class classp)
  818.     (standard-class standard-class-p)
  819.     (funcallable-standard-class funcallable-standard-class-p)
  820.     (structure-class structure-class-p)
  821.     (forward-referenced-class forward-referenced-class-p)))
  822.  
  823.